home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / st80_pr4.lha / st80_pre4 / MoDE / NetworkMode-Shan.st < prev    next >
Text File  |  1993-07-24  |  14KB  |  631 lines
  1. ExpandedMode subclass: #NetMode
  2.     instanceVariableNames: 'image '
  3.     classVariableNames: ''
  4.     poolDictionaries: ''
  5.     category: 'NetworkMode-Shan'!
  6.  
  7.  
  8. !NetMode methodsFor: 'buffering'!
  9.  
  10. bufferAll
  11.     image _ self image!
  12.  
  13. unBuffer
  14.     image _ nil! !
  15.  
  16. !NetMode methodsFor: 'displaying'!
  17.  
  18. displayOn: aMedium in: aRect 
  19.     "Clip the display to aRect."
  20.     " Shan April 6, 1989"
  21.  
  22.     | r |
  23.     visible ifTrue: [image isNil
  24.             ifTrue: [(self displayBackgroundOn: aMedium in: aRect)
  25.                     ifTrue: [self displaySubViewsOn: aMedium in: aRect]]
  26.             ifFalse: 
  27.                 [aRect isNil
  28.                     ifTrue: [r _ self displayBox]
  29.                     ifFalse: [r _ aRect].
  30.                 image
  31.                     displayOn: aMedium
  32.                     at: self unclippedDisplayBox origin
  33.                     clippingBox: r]]! !
  34.  
  35. !NetMode methodsFor: 'initialize-release'!
  36.  
  37. initialize
  38.     super initialize.
  39.     self borderWidth: 2.
  40.     self insideColor: Form white.
  41.     painter _ true! !
  42.  
  43. NetMode subclass: #OddShapeNetMode
  44.     instanceVariableNames: ''
  45.     classVariableNames: ''
  46.     poolDictionaries: ''
  47.     category: 'NetworkMode-Shan'!
  48.  
  49.  
  50. !OddShapeNetMode methodsFor: 'event-handling'!
  51.  
  52. interestedIn: event 
  53.     "This is exactly the same as in the FixedImageMode class.  Eventually 
  54.     the ability of buffering in the NetMode should be promoted to Mode 
  55.     class and this class should be a subclass of FixedImageMode.  Shan 
  56.     July 16, 1989"
  57.  
  58.     | relativePt |
  59.     visible & (self containsPoint: event origin) ifFalse: [^false].
  60.     relativePt _ event origin - self unclippedDisplayBox origin.
  61.     (dispObj containsPoint: relativePt)
  62.         ifTrue: [^true]
  63.         ifFalse: [^false]! !
  64.  
  65. !OddShapeNetMode methodsFor: 'displaying'!
  66.  
  67. displayOn: aMedium in: aRect 
  68.     super displayOn: aMedium in: aRect! !
  69.  
  70. SemanticObject subclass: #NetNode
  71.     instanceVariableNames: 'linkability links '
  72.     classVariableNames: 'NetNodeMiddleButtonMenu '
  73.     poolDictionaries: ''
  74.     category: 'NetworkMode-Shan'!
  75.  
  76.  
  77. !NetNode methodsFor: 'access'!
  78.  
  79. addLink: aLink
  80.     "Shan July 23, 1989"
  81.  
  82.     links add: aLink!
  83.  
  84. linkability
  85.     "Shan October 21, 1989"
  86.  
  87.     ^linkability! !
  88.  
  89. !NetNode methodsFor: 'middleMenu support'!
  90.  
  91. curveLink
  92.     "Shan October 21, 1989"!
  93.  
  94. curveLinkNamed
  95.     "Shan October 21, 1989"!
  96.  
  97. editName
  98.     "Shan October 21, 1989"!
  99.  
  100. link
  101.     "Shan October 21, 1989"
  102.     "This is just a quick prototype.  Shan April 12, 1989"
  103.     "The drag mechanism handles the connection between the two nodes 
  104.     involved.  See the connect: method in the controller-msg protocol for 
  105.     implementation.  Shan July 17, 1989"
  106.  
  107.     | startPt |
  108.     startPt _ mode unclippedDisplayBox center.
  109.     mode controller rubberLineOriginCltn: (OrderedCollection with: startPt)
  110.                 within: mode superView displayBox!
  111.  
  112. linkable
  113.     "Shan October 21, 1989"
  114.     "Toggal the linkability of a node.  Shan July 16, 1989"
  115.  
  116.     linkability _ linkability not!
  117.  
  118. linkNamed
  119.     "Shan October 21, 1989"! !
  120.  
  121. !NetNode methodsFor: 'menu access'!
  122.  
  123. middleButtonMenu
  124.     "Shan October 21, 1989"
  125.  
  126.     NetNodeMiddleButtonMenu isNil ifTrue: [^NetNodeMiddleButtonMenu _ ActionMenu
  127.                     labels: 'Edit Name\Link\Linkable/Unlinkable\Curve Link\Link Named\Curve Link Named' withCRs
  128.                     lines: #(1 3 )
  129.                     selectors: #(#editName #link #linkable #curveLink #linkNamed #curveLinkNamed )].
  130.     ^NetNodeMiddleButtonMenu! !
  131.  
  132. !NetNode methodsFor: 'controller-msg'!
  133.  
  134. connect: e 
  135.     "Link the two mode.  Shan July 17, 1989"
  136.  
  137.     | link |
  138.     Cursor wait showWhile: [self linkability
  139.             ifTrue: 
  140.                 [link _ NetLink from: e data mode semanticObject to: self.
  141.                 mode superMode addToBackSubMode: link mode.
  142.                 link mode display]]!
  143.  
  144. move: e 
  145.     "Move the node with the links following it.  Shan July 19, 1989"
  146.  
  147.     | center pCltn lDBox lMode |
  148.     center _ mode unclippedDisplayBox center.
  149.     pCltn _ OrderedCollection new.
  150.     links do: 
  151.         [:each | 
  152.         each fromMode ~= mode
  153.             ifTrue: [pCltn add: each fromMode unclippedDisplayBox center]
  154.             ifFalse: [pCltn add: each toMode unclippedDisplayBox center].
  155.         each eraseLink].
  156.     mode controller moveImageWithin: nil linkTo: pCltn.
  157.     links do: 
  158.         [:each | 
  159.         each updateLinkPosition.
  160.         each show]!
  161.  
  162. processEnter: e 
  163.     "Semantic feedback.  Shan July 17, 1989"
  164.  
  165.     linkability ifTrue: [mode highlight]! !
  166.  
  167. !NetNode methodsFor: 'drag support'!
  168.  
  169. dragControllerFor: aSymbol 
  170.     "Shan July 14, 1989"
  171.  
  172.     | ctrl erDict |
  173.     aSymbol == #link
  174.         ifTrue: 
  175.             [ctrl _ OpaqueController1 new.
  176.             erDict _ ctrl eventResponses deepCopy.
  177.             erDict at: #enterMode put: #processEnter:.
  178.             erDict at: #leaveMode put: #deHighlight.
  179.             erDict at: #leftButtonDown put: #connect:.
  180.             ctrl eventResponses: erDict.
  181.             ^ctrl].
  182.     ^super dragControllerFor: aSymbol! !
  183.  
  184. !NetNode methodsFor: 'initialize-release'!
  185.  
  186. initialize
  187.     "Shan July 17, 1989"
  188.  
  189.     super initialize.
  190.     linkability _ true.
  191.     links _ OrderedCollection new! !
  192.  
  193. !NetNode methodsFor: 'MMS-initializations'!
  194.  
  195. setUpAppearance
  196.     "Shan July 16, 1989"
  197.  
  198.     super setUpAppearance.
  199.     mode extent: 80 @ 30.
  200.     mode borderWidth: 1.
  201.     mode insideColor: Form white.
  202.     mode highlightDispObj: "#inverseHighlight" "#colorBorderHighlight" #thickBorderHighlight!
  203.  
  204. setUpController
  205.     "Shan July 16, 1989"
  206.  
  207.     | ctrl |
  208.     ctrl _ NetNodeController1 new.
  209.     mode controller: ctrl! !
  210.  
  211. SemanticObject subclass: #Net
  212.     instanceVariableNames: ''
  213.     classVariableNames: 'NetMiddleButtonMenu '
  214.     poolDictionaries: ''
  215.     category: 'NetworkMode-Shan'!
  216.  
  217.  
  218. !Net methodsFor: 'middleMenu support'!
  219.  
  220. absoluteBufferSubViews
  221.     "Shan October 21, 1989" 
  222.  
  223.     mode absoluteBufferSubViews!
  224.  
  225. bufferAll
  226.     "Shan October 21, 1989" 
  227.  
  228.     mode bufferAll!
  229.  
  230. createNode
  231.     "Shan October 21, 1989" 
  232.     | aNetNode m name dispObj nameOffset e|
  233.     e _ mode controller event.
  234.     aNetNode _ NetNode new.
  235.     "Collect the necessary information.  Shan April 2, 1989"
  236.     self eventQueue disable.
  237.     FillInTheBlank
  238.         request: 'Type a name. (use menu to accept)'
  239.         displayAt: e origin
  240.         centered: true
  241.         action: [:resp | name _ resp]
  242.         initialAnswer: 'Name of the node'.
  243.     "aNetNode attachModeTo: mode at: (mode inverseDisplayTransform: e origin)."
  244.     mode addSubMode: aNetNode mode absAt: e origin.
  245.     m _ aNetNode mode.
  246. Cursor wait showWhile: [    dispObj _ m displayObject.
  247.     nameOffset _ 2 @ 2.
  248.     dispObj relAdd: (name asDisplayText offset: nameOffset).
  249.     m unclippedDisplayBox extent > dispObj boundingBox extent ifFalse: [m setUnclippedDisplayBoxExtent: (dispObj boundingBox extent + ((nameOffset + m borderWidth) * 2))].
  250.     m display.
  251.     "This will remove the late menu syndrom."
  252.     self eventQueue enable]!
  253.  
  254. normalDrawSpeed
  255.     "Shan October 21, 1989" 
  256.  
  257.     mode unBuffer!
  258.  
  259. normalDrawSpeed: e
  260.     mode unBuffer!
  261.  
  262. redrawAll
  263.     "Shan October 21, 1989" 
  264.  
  265.     mode display!
  266.  
  267. smartBufferSubViews
  268.     "Shan October 21, 1989" 
  269.  
  270.     mode smartBufferSubViews!
  271.  
  272. smartBufferSubViews: e
  273.     mode smartBufferSubViews!
  274.  
  275. toBack
  276.     "Shan October 21, 1989" 
  277.  
  278.     mode toBack!
  279.  
  280. toFront
  281.     "Shan October 21, 1989" 
  282.  
  283.     mode toFront! !
  284.  
  285. !Net methodsFor: 'menu access'!
  286.  
  287. middleButtonMenu
  288.     "Shan October 21, 1989"
  289.     NetMiddleButtonMenu isNil ifTrue: [^NetMiddleButtonMenu _ ActionMenu
  290.         labels: 'New Node\Redraw All\To Front\To Back\Draw faster\Draw veryFast\Draw absoluteFast\Slow Draw' withCRs
  291.         lines: #(1 4 )
  292.         selectors: #(createNode  redrawAll  toFront  toBack  smartBufferSubViews  absoluteBufferSubViews  bufferAll  normalDrawSpeed  )].
  293.     ^NetMiddleButtonMenu! !
  294.  
  295. !Net methodsFor: 'MMS-initializations'!
  296.  
  297. defaultMMSControllerClass
  298.     "Shan August 7, 1989"
  299.  
  300.     ^MidMenuAndMoveController!
  301.  
  302. defaultModeClass
  303.     "Shan July 21, 1989"
  304.     ^NetMode! !
  305. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  306.  
  307. Net class
  308.     instanceVariableNames: ''!
  309.  
  310.  
  311. !Net class methodsFor: 'testing'!
  312.  
  313. oddShapeTest1
  314.     "(RootMode new addSubMode: self oddShapeTest1) startUp" 
  315.  
  316.     | rMode aNet anOddNet sMode2 dispObj line lMode |
  317.     rMode _ ExpandedMode new.
  318.     aNet _ Net new.
  319.     anOddNet _ OddShapeNet new.
  320.     "aNet mode setPainter: false."
  321.     anOddNet mode setPainter: false.
  322.     sMode2 _ Simple newMode.
  323.     sMode2 insideColor: Form darkGray.
  324.     lMode _ LineMode
  325.                 from: 20 @ 20
  326.                 to: 120 @ 120
  327.                 width: 2 @ 2
  328.                 color: Form black.
  329.     lMode controller: MoveImageController1 new.
  330.     aNet
  331.         attachModeTo: rMode
  332.         at: 150 @ 50
  333.         extent: 600 @ 500.
  334.     anOddNet
  335.         attachModeTo: rMode
  336.         at: 250 @ 350.
  337.     rMode addSubMode: lMode.
  338.     rMode
  339.         addSubMode: sMode2
  340.         at: 50 @ 150
  341.         extent: 100 @ 100.
  342.     ^rMode resizeStyle: ResizeStyle stickFourCorners! !
  343.  
  344. Net subclass: #OddShapeNet
  345.     instanceVariableNames: ''
  346.     classVariableNames: ''
  347.     poolDictionaries: ''
  348.     category: 'NetworkMode-Shan'!
  349.  
  350.  
  351. !OddShapeNet methodsFor: 'MMS-initializations'!
  352.  
  353. defaultModeClass
  354.     "Shan July 21, 1989"
  355.     ^OddShapeNetMode!
  356.  
  357. setUpAppearance
  358.     "Shan July 16, 1989"
  359.  
  360.     super setUpAppearance.
  361.     mode borderWidth: 0.
  362.     mode insideColor: nil.
  363.     mode displayObject absAdd: (MMSOpaqueForm oddMode).
  364.     mode window: MMSOpaqueForm oddMode boundingBox.! !
  365.  
  366. MController subclass: #NetNodeController1
  367.     instanceVariableNames: ''
  368.     classVariableNames: 'NetNodeController1ERD '
  369.     poolDictionaries: ''
  370.     category: 'NetworkMode-Shan'!
  371.  
  372. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  373.  
  374. NetNodeController1 class
  375.     instanceVariableNames: ''!
  376.  
  377.  
  378. !NetNodeController1 class methodsFor: 'access'!
  379.  
  380. eventResponsesDict
  381.     ^NetNodeController1ERD! !
  382.  
  383. !NetNodeController1 class methodsFor: 'initialize'!
  384.  
  385. ERDinit
  386.  
  387.     NetNodeController1ERD _ super eventResponsesDict deepCopy.
  388.     NetNodeController1ERD at: #middleButtonDown put: #expandMiddleMenu.
  389.     NetNodeController1ERD at: #enterMode put: #highlight.
  390.     NetNodeController1ERD at: #leftButtonDown put: #move:.
  391.     NetNodeController1ERD at: #leaveMode put: #deHighlight.! !
  392.  
  393. SemanticObject subclass: #NetLink
  394.     instanceVariableNames: 'from to shown '
  395.     classVariableNames: 'NetLinkMiddleButtonMenu '
  396.     poolDictionaries: ''
  397.     category: 'NetworkMode-Shan'!
  398.  
  399.  
  400. !NetLink methodsFor: 'private'!
  401.  
  402. from: sF to: sT width: p color: f 
  403.     "Shan August 10, 1989"
  404.  
  405.     from _ sF.
  406.     to _ sT.
  407.     mode
  408.         from: from mode viewport center
  409.         to: to mode viewport center
  410.         width: p
  411.         color: f.
  412.     from addLink: self.
  413.     to addLink: self! !
  414.  
  415. !NetLink methodsFor: 'access'!
  416.  
  417. from
  418.     "Shan August 10, 1989"
  419.  
  420.     ^from!
  421.  
  422. fromMode
  423.     "Shan July 23, 1989"
  424.  
  425.     ^from mode!
  426.  
  427. theOtherEndOf: anSemObj 
  428.     "The from and to instance var. of a Link usually store semObjs.
  429.     Shan August 8, 1989"
  430.  
  431.     from ~= anSemObj
  432.         ifTrue: [^from]
  433.         ifFalse: [^to]!
  434.  
  435. theOtherModeOf: aMode 
  436.     "A link connects two modes.  This one returns the mode other than 
  437.     aMode.  aMode is assumed to be one of the modes the link connects.
  438.     Shan August 8, 1989"
  439.  
  440.     ^(self theOtherEndOf: aMode semanticObject) mode!
  441.  
  442. to
  443.     "Shan August 10, 1989"
  444.  
  445.     ^to!
  446.  
  447. toMode
  448.     "Shan July 23, 1989"
  449.  
  450.     ^to mode! !
  451.  
  452. !NetLink methodsFor: 'MMS-initializations'!
  453.  
  454. defaultMMSControllerClass
  455.     "Lines don't process events.  Should pass them to the back modes.  
  456.     Shan August 23, 1989"
  457.  
  458.     ^MController!
  459.  
  460. defaultModeClass
  461.     "Shan August 24, 1989"
  462.  
  463.     ^LineMode! !
  464.  
  465. !NetLink methodsFor: 'initialize-release'!
  466.  
  467. initialize
  468.     "Shan August 12, 1989"
  469.  
  470.     super initialize.
  471.     shown _ true! !
  472.  
  473. !NetLink methodsFor: 'connection support'!
  474.  
  475. removeMode
  476.     "Shan August 12, 1989"
  477.  
  478.     mode removeFromSuperMode.
  479.     mode release! !
  480.  
  481. !NetLink methodsFor: 'display management'!
  482.  
  483. eraseLink
  484.     "Shan August 12, 1989"
  485.  
  486.     mode eraseAndUnMap!
  487.  
  488. hide
  489.     "Shan August 12, 1989"
  490.  
  491.     mode eraseAndUnMap.
  492.     shown _ false!
  493.  
  494. isShown
  495.     "Shan August 12, 1989"
  496.  
  497.     ^shown!
  498.  
  499. show
  500.     "Shan August 12, 1989"
  501.  
  502.     mode mapAndDisplay.
  503.     shown _ true!
  504.  
  505. showTheOtherEndOf: aDel 
  506.     "Shan August 12, 1989"
  507.  
  508.     to == aDel
  509.         ifTrue: [from mode mapAndDisplay]
  510.         ifFalse: [to mode mapAndDisplay]!
  511.  
  512. updateLinkPosition
  513.     "Shan August 8, 1989"
  514.  
  515.     mode displayObject clear.
  516.     mode
  517.         from: from mode viewport center
  518.         to: to mode viewport center
  519.         width: 2@2
  520.         color: Form black! !
  521. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  522.  
  523. NetLink class
  524.     instanceVariableNames: ''!
  525.  
  526.  
  527. !NetLink class methodsFor: 'instance creation'!
  528.  
  529. from: fromMode to: toMode
  530.     "Shan July 23, 1989"
  531.  
  532.     ^self new
  533.         from: fromMode
  534.         to: toMode
  535.         width: 2@2
  536.         color: Form black!
  537.  
  538. from: fromMode to: toMode width: aPoint color: aMask 
  539.     "Shan July 23, 1989"
  540.  
  541.     ^self new
  542.         from: fromMode
  543.         to: toMode
  544.         width: aPoint
  545.         color: aMask! !
  546.  
  547. Object subclass: #ToolGhost
  548.     instanceVariableNames: ''
  549.     classVariableNames: 'GhostBitBlt '
  550.     poolDictionaries: ''
  551.     category: 'NetworkMode-Shan'!
  552. ToolGhost comment:
  553. 'ToolGhost draws a ghost line between two given points.
  554.     A ghost line is a line which is drawn by taking the reverse of each current pixel value on the straight line between the two given points.
  555.  
  556. This capability is implemented by drawing a line with a pixel size black form using a combination rule which specifies reversal of destination (the display screen) pixels affected.  Thus, black lines on the screen will become white if drawn over with a ghost line, wheras ''white lines'' will become black when drawn over by a ghost line.  This is especially useful in drawing links in the network mode: as the user is moving the mouse to select the endpoint node for the link, the link is successively drawn and erased --both with ToolGhost.  Final lines use drawing package methods in lieu of ToolGhost.
  557.  
  558. The implementation is dependent upon the system class BitBlt.
  559.  
  560. Done:
  561.     -) checked over -- documentation added.  "peb - 1 June 1987"
  562.  
  563. '!
  564.  
  565. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  566.  
  567. ToolGhost class
  568.     instanceVariableNames: ''!
  569.  
  570.  
  571. !ToolGhost class methodsFor: 'flush'!
  572.  
  573. initialize
  574.     "reset the bit blit"
  575.     "ToolGhost initialize"
  576.  
  577.     GhostBitBlt _ nil.
  578.  
  579. "gjf - ?"! !
  580.  
  581. !ToolGhost class methodsFor: 'line'!
  582.  
  583. from: p0 to: p1
  584.     "Invert a line on the display from  point p0 to point p1."
  585.  
  586.     self from: p0 to: p1 clip: nil
  587.  
  588. "gjf - 30 March 1987"!
  589.  
  590. from: p0 to: p1 clip: aRect
  591.     "Invert a line on the display from point p0 to point p1"
  592.  
  593.     | clipRect | 
  594.  
  595. "Allow nil as a clipping rectangle"
  596.     aRect isNil 
  597.         ifTrue: [clipRect _ Display boundingBox]
  598.         ifFalse: [clipRect _ aRect].
  599. "Smalltalk implementation"
  600.     GhostBitBlt isNil ifTrue:
  601.         [GhostBitBlt _ BitBlt
  602.             destForm: Display
  603.             sourceForm: (Form extent: 1@1)  black  "as if drawing with a black pen"
  604.             halftoneForm: Form black
  605.             combinationRule: 6    "reverse rule"
  606.             destOrigin: 0@0
  607.             sourceOrigin: 0 @ 0
  608.             extent: 1@1
  609.             clipRect: clipRect.].
  610.     GhostBitBlt clipRect: clipRect.
  611.     GhostBitBlt destOrigin: p0.
  612.     GhostBitBlt drawFrom: p0 to: p1.
  613.  
  614. "gjf - 30 March 1987"!
  615.  
  616. starFrom: p0 to: aCollection
  617.     "Invert the lines on the display from point p0 to each of the points in aCollection.  (Thus making a 'star' with point p0 in the center)."
  618.  
  619.     aCollection do: [:eachPoint | self from: p0 to: eachPoint]
  620.  
  621. "gjf - ?"!
  622.  
  623. starFrom: p0 to: aCollection clip: aRect
  624.     "Invert the lines on the display from point p0 to each of the points in aCollection.  Also, use a Rect as the clipping rectangle."
  625.  
  626.     aCollection do: [:eachPoint | self from: p0 to: eachPoint clip: aRect]
  627.  
  628. "gjf - ?"! !
  629.  
  630. ToolGhost initialize!
  631.